home *** CD-ROM | disk | FTP | other *** search
/ SPACE 2 / SPACE - Library 2 - Volume 1.iso / utility / 95 / pascal / degas.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-01-15  |  5.6 KB  |  230 lines
  1. {$P-} { turn pointer checking off.. }
  2. program degas;
  3.  
  4. {
  5.  
  6.         Program to save and restore the ST display to/from degas files.
  7.  
  8.         12/9/86 MJC
  9.  
  10.         Copyright 1986 By OSS, Inc.  All Rights Reserved.
  11.  
  12.         Use this code at your own risk.
  13. }
  14.  
  15. CONST
  16.         Mono = 2;               { monochrome screen resolution }
  17.  
  18. TYPE
  19.  
  20.         { The ST screen is 32000 bytes of data, soooo.... }
  21.         Screen = packed array [ 0..31999 ] of BYTE;
  22.  
  23.         Ptr_screen = ^Screen;   { pointer to the screen array }
  24.  
  25.         Palette = Packed Array [ 0..15 ] of Integer;
  26.  
  27.         Resolution = Integer;
  28.  
  29.         Degas_scrn = PACKED RECORD
  30.               Res : Resolution;
  31.               Pal : Palette;
  32.               Pic : Screen;
  33.            End;
  34.  
  35. VAR
  36.  
  37.         S_ptr : Ptr_screen;     { a pointer to a packed array of bytes... }
  38.         SavScrn : Screen;       { a place to save the current screen }
  39.         File_nam : String;      { Temp file name..                      }
  40.  
  41. { **********************************************************************
  42.  
  43.         declare routine to get address of screen
  44.  
  45.   *********************************************************************** }
  46.  
  47. { physbase returns a pointer to the start of the ST's screen.  }
  48.  
  49. FUNCTION Physbase : Ptr_screen;
  50.    XBIOS( 2 );
  51.  
  52. FUNCTION Getrez : Resolution;
  53.    XBIOS( 4 );
  54.  
  55. PROCEDURE Setscreen( Logadr, Physadr : Long_Integer; Res : Resolution );
  56.    XBIOS( 5 );
  57.  
  58. PROCEDURE Setpalette( VAR Pal : Palette );
  59.    XBIOS( 6 );
  60.  
  61. FUNCTION Setcolor( N , Color : Integer ) : Integer;
  62.    XBIOS( 7 );
  63.  
  64.  
  65.  
  66. { ***********************************************************************
  67.  
  68.         save screen to degas file.
  69.  
  70.   *********************************************************************** }
  71.  
  72.  
  73. PROCEDURE SSave( name : STRING );
  74.  
  75. VAR
  76.  
  77.    f : File of Degas_scrn;         { a file containing a degas screen }
  78.    i : Integer;
  79.  
  80.    BEGIN
  81.  
  82.         rewrite( f, name ) ;       { bind f to file name }
  83.  
  84.         S_ptr := Physbase;         { grab location of screen... }
  85.  
  86.         f^.Res := Getrez;          { get resolution word }
  87.  
  88.         FOR i := 0 TO 15 DO        { get color palette }
  89.            f^.Pal[ i ] := Setcolor( i, -1 );
  90.  
  91.         f^.Pic := S_ptr^;          { get screen data }
  92.  
  93.         put( f );                  { and write it out to file }
  94.  
  95.         { file is automatically closed when we leave this procedure. }
  96.  
  97.    END;
  98.  
  99. { ***************************************************************************
  100.  
  101.         Restore screen data from degas file.
  102.  
  103.   *************************************************************************  }
  104.  
  105. PROCEDURE SRestore( name : STRING );
  106.  
  107. VAR
  108.    i : Integer;
  109.    f : file of Degas_scrn;     { a file containing a screenful of bytes.. }
  110.    Rez : Resolution;
  111.    Oldpal : Palette;
  112.  
  113.    BEGIN
  114.  
  115.         Rez := Getrez;
  116.         S_ptr := Physbase;              { grab location of screen... }
  117.  
  118.         reset( f, name );               { bind f to file name }
  119.  
  120.         { reset automatically fills file buffer with data from first record }
  121.  
  122.         { decide if resolution can be changed...                }
  123.         IF ( ( f^.Res < Mono ) AND ( Rez < Mono ) ) THEN
  124.               Setscreen( -1, -1, f^.Res );
  125.  
  126.         { now check for picture compatability...                }
  127.  
  128.         IF ( ( f^.Res = Mono ) AND ( Rez = Mono )
  129.           OR
  130.            ( Rez < Mono ) AND ( f^.Res < Mono ) ) THEN
  131.            Begin
  132.               For i:= 0 TO 15 DO              { save palette          }
  133.                  Oldpal[ i ] := Setcolor( i, -1 );
  134.  
  135.               Setpalette( f^.Pal );           { use degas palette     }
  136.  
  137.               SavScrn := S_ptr^;              { save current screen       }
  138.               S_ptr^ := f^.Pic;               { stuff picture into screen }
  139.  
  140.               Readln;
  141.               S_Ptr^ := SavScrn;              { restore old screen            }
  142.               Setpalette( Oldpal );           { restore old palette           }
  143.               Setscreen( -1, -1, Rez )        { restore old resolution        }
  144.  
  145.            End;
  146.         { file is automatically closed when we leave this procedure. }
  147.    END;
  148.  
  149.  
  150. { *********************************************************************
  151.  
  152.         miscellaneous subroutines...
  153.  
  154. *********************************************************************** }
  155.  
  156.  
  157. PROCEDURE waitCR;
  158.  
  159.    BEGIN
  160.  
  161.         writeln('Press <RETURN> to continue. ');
  162.         readln;
  163.  
  164.    END;
  165.  
  166.  
  167. { clear screen procedure }
  168.  
  169. PROCEDURE cls;
  170.  
  171.    BEGIN
  172.  
  173.         write( chr( 27 ) );
  174.         write( 'E' );
  175.  
  176.    END;
  177.  
  178.  
  179. { put some stupid stuff on the screen... }
  180.  
  181. PROCEDURE fill_scrn;
  182.  
  183.    VAR
  184.  
  185.         i : integer;
  186.  
  187.    BEGIN
  188.  
  189.         cls;    { clear screen ... }
  190.  
  191.         FOR i := 0 TO 20 DO
  192.            BEGIN
  193.                 writeln('This is line # ', i );
  194.            END;
  195.    END;
  196.  
  197.  
  198.  
  199. { ************************************************************************
  200.  
  201.         Main routine starts here.  Just execute routines in sequence...
  202.  
  203.   ************************************************************************ }
  204.  
  205.  
  206. BEGIN
  207.  
  208.         fill_scrn;              { put junk on screen.... }
  209.  
  210.         writeln('saving screen...');
  211.  
  212.         File_nam := 'Test.pi';  { start a file name }
  213.         File_nam := Concat(
  214.            File_nam, Chr( Getrez + Ord( '1' ) ) ); { add extender }
  215.  
  216.         SSave( File_nam );    { write screen data to file... }
  217.  
  218.         waitCR;
  219.  
  220.         cls;                    { clear screen... }
  221.  
  222.         writeln('restoring screen...');
  223.  
  224.         SRestore( File_nam ); { read screen data from file... }
  225.  
  226.         waitCR;
  227.  
  228. END.
  229.  
  230. əəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəəə